COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	.require "memo.pub[let,jmc]" source
C00010 ENDMK
C⊗;
.require "memo.pub[let,jmc]" source;

.cb CS206
.cb Improving a Program for Building Structures out of blocks

	We describe a program for transforming one structure made
of piles of blocks into another.  This program is suboptimal in a
certain way, and the problem is to fix this deficiency.  We represent
a structure as a list of towers and a tower as a list of blocks.
Thus the expression ((A B) (C)) represents a structure in which block
A  is on block  B  which is on the table, and block  C  is on the
table by itself.  The move of putting block  A  onto block  C  is
represented by  (A C).  We require that a block and its destination
be clear before a move can be made.  Putting block  A  on the table
will be represented by  (A TABLE).  We assume that the table can hold
as many blocks as we want.

	The program represents a situation by a pair consisting of
the structure existing in that situation and a list of the moves
leading to it.  For example, the situation after the structure  ((A B C))
has been built from the above initial configuration will be
(((A B C)) (A B) (B C) (A TABLE)) if the blocks have been moved
optimally, and the initial situation itself is (((A B) (C))), which is
the same as the pair (((A B) (C)).NIL).

	The main function is  (BUILD STRUCTURE S)  where the variable
STRUCTURE  represents the structure to be built and  S  is the current
situation.  The value of  (BUILD STRUCTURE S)  is the final situation.
Thus  (BUILD '((A B C)) '(((A B) (C)))) => (((A B C)) (A B) (B C) (A TABLE)).
BUILD  calls  BUILD1  for each tower in the desired structure and  BUILD1
builds the towers.  It does so by using  MOVE  to move each block from
where it is to the final position, building the tower bottom up.  MOVE
has to clear the block to be moved and the block onto which it is to
be put which it does by calling  CLEAR.  CLEAR  puts any necessary blocks
on the table.  The computation of new situations is actually done by
the function  UPDATE.

	There are a few more auxiliary functions which you shouldn't
have much difficulty understanding.

	Now for the desired improvement.  When a block is cleared,
the blocks that have to be moved are put on the table.  Sometimes
however, a block could be moved directly to its final position.
The problem is to modify  BUILD  and its auxiliary functions to
attain this goal.  Note that this still won't always give a minimal sequence
of moves.  Other than searching the space of sequences of moves, I
don't know an algorithm for finding a minimal sequence.

	Making the requested improvement is not absolutely trivial.


(defun build (structure s)
       (if (null structure)
	   s
	   (build (cdr structure)
		   (build1 (reverse (car structure)) 'table s))))

(defun build1 (rtower location s)
       (if (null rtower)
	   s
	   (build1 (cdr rtower) (car rtower)
		  (move (car rtower) location s))))

(defun move (block location s)
       (if (on block location (car s)) 
	   s
	   (immove block
		   location
		   (clear block (clear location s)))))

(defun immove (block location s)
       (cons (update
	      (car s)
	      (list block location))
	     (cons (list block location) (cdr s))))

(defun clear (block s)
       (if (or (null block) (eq block 'table))
	   s
	   (clear1 block (find block (car s)) s)))

(defun update1 (s1 pair)
       (cond
	((or (null s1) (and (null (car pair)) (null (cadr pair))))
	 s1)
	((eq (caar s1) (car pair))
	 (cons (cdar s1) (update1 (cdr s1) pair)))
	((eq (caar s1) (cadr pair))
	 (cons (cons (car pair) (car s1))
	       (update1 (cdr s1) (list (car pair) nil))))
	(t
	 (cons (car s1) (update1 (cdr s1) pair)))))

(defun update (s1 pair)
       (update2 (if (eq (cadr pair) 'table)
		    (cons (list (car pair)) (update1 s1 (cons (car pair) nil)))
		    (update1 s1 pair))))

(defun update2 (s1) (cond
		     ((null s1) nil)
		     ((null (car s1)) (cdr s1))
		     (t (cons (car s1) (update2 (cdr s1))))))

(defun find (b s1) (if (member b (car s1)) (car s1) (find b (cdr s1))))

(defun clear1 (b tower s)
       (if (eq b (car tower))
	   s
	   (clear1 b (cdr tower) (immove (car tower) 'table s))))

(defun on (a b s1) (on1 a b (find a s1)))
       
(defun on1 (a b tower)
       (and (not (null tower))
	    (or (and (eq (car tower) a)
		     (or (and (eq b 'table) (null (cdr tower)))
			 (and (not (null (cdr tower))) (eq (cadr tower) b))))
		(on1 a b (cdr tower)))))

;;; tests
(setq st1 '((a b) (c)))
(setq st2 '((a b c)))
(setq s0 (cons t1 nil))
(setq tt0 '(b c))
(immove 'a 'c s0)
(move 'a 'c s0)
(immove 'a 'table s0)
(build1 '(c) 'a s0)
(build1 '(c b) 'table s0)
(build st2 s0)
(setq st3 '((a b c) (d e) (f)))
(setq st4 '((a b c d f) (e)))
(build st4 (cons st3 nil))
(setq st5 '((c b) (a d e) (f)))
(build st5 (cons st3 nil))